home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 6 / Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso / 037a / pavt110.zip / A1DEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1991-09-07  |  6KB  |  260 lines
  1. program A_1_Demo; { Demo of Avatar level 1 console using Crt routines }
  2.                   { Public Domain.  Author: Greg Smith                }
  3.                   { Modification History:                             }
  4.                   {        07/06/91   First Coding                    }
  5. {$D-,L-,R-,F-,M 4096,4096,4096}
  6. Uses Dos, Crt, PAvt1;
  7.  
  8. type
  9.   ScreenWord = record
  10.                  chr  : char;
  11.                  attr : byte;
  12.                end;
  13.   ScreenPtr = ^Screen;
  14.   Screen = Array[1..25,1..80] of ScreenWord;
  15.  
  16. var
  17.   ScrPtr : ScreenPtr; { for direct screen writes }
  18.  
  19. {$IFDEF VER55}
  20. Function DV_Get_Video_Buffer(cseg:word): word;
  21. begin
  22.   if DESQview_version = 0 then DV_Get_Video_Buffer := 0
  23.    else
  24.     InLine(
  25.       $b4/$fe/    {  MOV    AH,0FEH          DV's get video buffer function }
  26.       $cd/$10/    {  INT    10H              Returns ES:DI of alt buffer }
  27.       $8c/$c0);   {  MOV    AX,ES            Return video buffer }
  28. end; { DV_Get_Video_Buffer }
  29. {$ELSE}
  30. Function DV_Get_Video_Buffer(cseg:word): word; assembler;
  31. asm
  32.   MOV    ES,cseg            { Put current segment into ES }
  33.   CALL   DESQview_version   { Returns AX=0 if not in DV }
  34.   TEST   AX,AX              { In DV? }
  35.   JZ     @DVGVB_X           { Jump if not }
  36.   MOV    AH,0FEH            { DV's get video buffer function }
  37.   INT    10H                { Returns ES:DI of alt buffer }
  38.   MOV    AX,ES              { Return video buffer }
  39.   JMP    @DVGVB_E           { Exit and return DV buffer }
  40. @DVGVB_X:
  41.   MOV    AX,cseg            { Load old buffer for return to caller }
  42. @DVGVB_E:
  43. end; { DV_Get_Video_Buffer }
  44. {$ENDIF}
  45.  
  46. Procedure SetScrPtr;
  47. var
  48.   sg : word;
  49. begin
  50.   if LastMode = 7 then sg := $B000
  51.    else sg := $B800;
  52.   sg := DV_Get_Video_Buffer(sg);
  53.   ScrPtr := Ptr(sg,$0000);
  54. end;
  55.  
  56. (* Hooks *)
  57.  
  58. {$F+}
  59. procedure SetXY(x,y:byte);
  60. begin
  61.   GotoXY(x,y);
  62. end;
  63.  
  64. procedure WriteAT(x,y,a:byte;ch:char);
  65. begin
  66.   with ScrPtr^[y,x] do
  67.    begin
  68.      attr := a;
  69.      chr := ch;
  70.    end;
  71. end;
  72.  
  73. procedure GetXY(var x,y:byte);
  74. begin
  75.   x := WhereX;
  76.   y := WhereY;
  77. end;
  78.  
  79. procedure FillArea(x1,y1,x2,y2,a:byte;ch:char);
  80. var
  81.   w,z : byte;
  82. begin
  83.   for w := y1 to y2 do
  84.    for z := x1 to x2 do
  85.     WriteAT(z,w,a,ch);
  86. end;
  87.  
  88. procedure Scroll(dir,x1,y1,x2,y2,n,a:byte);
  89. var
  90.   t : byte;
  91. begin
  92.   if n = 0 then
  93.    begin
  94.      FillArea(x1,y1,x2,y2,a,' ');
  95.      exit;
  96.    end;
  97.   case dir of
  98.     1 : begin { up }
  99.           if n > succ(y2-y1) then n := succ(y2-y1);
  100.           for t := y1+n to y2 do
  101.            Move(ScrPtr^[t,x1], ScrPtr^[t-n,x1], succ(x2-x1)*2); { move a line }
  102.           FillArea(x1,succ(y2-n),x2,y2,a,' ');
  103.         end;
  104.     2 : begin { down }
  105.           if n > succ(y2-y1) then n := succ(y2-y1);
  106.           for t := y2-n downto y1 do
  107.            Move(ScrPtr^[t,x1], ScrPtr^[t+n,x1], succ(x2-x1)*2); { move a line }
  108.           FillArea(x1,y1,x2,pred(y1+n),a,' ');
  109.         end;
  110.     3 : begin { left }
  111.           if n > succ(x2-x1) then n := succ(x2-x1);
  112.           for t := y1 to y2 do
  113.            Move(ScrPtr^[t,x1+n], ScrPtr^[t,x1], succ(x2-(x1+n))*2);
  114.           FillArea(succ(x2-n),y1,x2,y2,a,' ');
  115.         end;
  116.     4 : begin { right }
  117.           if n > succ(x2-x1) then n := succ(x2-x1);
  118.           for t := y1 to y2 do
  119.            Move(ScrPtr^[t,x1], ScrPtr^[t,x1+n], succ(x2-(x1+n))*2);
  120.           FillArea(x1,y1,pred(x1+n),y2,a,' ');
  121.         end;
  122.   end; { case dir }
  123. end;
  124.  
  125. procedure GetScrChar(x,y:byte;var a:byte;var c:char);
  126. begin
  127.   with ScrPtr^[y,x] do
  128.    begin
  129.      a := attr;
  130.      c := chr;
  131.    end;
  132. end;
  133.  
  134. procedure HighArea(x1,y1,x2,y2,a:byte);
  135. var
  136.   i,j,m : byte;
  137.   c : char;
  138. begin
  139.   for i := x1 to x2 do
  140.    for j := y1 to y2 do
  141.     begin
  142.       GetScrChar(i,j,m,c);
  143.       WriteAT(i,j,a,c);
  144.     end;
  145. end;
  146.  
  147. procedure Pause(tens:word);
  148. begin
  149.   for tens := tens downto 1 do
  150.    begin
  151.      delay(100); { note that delay usually isn't accurate }
  152.      if KeyPressed then tens := 1; { abort the pause }
  153.    end;
  154. end;
  155. {$F-}
  156.  
  157. (* End Hook Definitions *)
  158.  
  159. procedure SetHooks;
  160. begin
  161. { Query_Hook := <defualt null hook for this application> }
  162.   Pauseh := Pause;
  163.   HighAreah := HighArea;
  164.   GetATh := GetScrChar;
  165.   FillAreah := FillArea;
  166.   Scrollh := Scroll;
  167.   GotoXYh := SetXY;
  168.   WriteATh := WriteAT;
  169. { FlushInputh := <Defualt Zero keyboard buffer hook is fine> }
  170. end;
  171.  
  172. function UpStr(s:string): string;
  173. var
  174.   ns : string;
  175.   i : integer;
  176. begin
  177.   for i := 1 to length(s) do
  178.    ns[i] := upcase(s[i]);
  179.   ns[0] := s[0];
  180.   UpStr := ns;
  181. end;
  182.  
  183. procedure Help;
  184. begin
  185.   Writeln('A-1 Demo  Copr. 1991 Greg Smith');
  186.   Writeln;
  187.   Writeln('Usage:  A1DEMO [params] input_file [params]');
  188.   Writeln;
  189.   Writeln(' parameters:');
  190.   Writeln('   /PLUS         Run in AVT/0+ simulation mode w/ ANSI fallback.');
  191.   Writeln('   /ANSI         Start with ANSI child active.');
  192.   Writeln('   /SLOW         Slow down emulation for viewing.');
  193.   halt;
  194. end;
  195.  
  196. var
  197.   fname : pathstr;
  198.  
  199. const
  200.   slowdown : byte = 0; { milliseconds between characters. }
  201.  
  202. procedure ProcessParams;
  203. const
  204.   Prms = '/PLUS/ANSI/SLOW/?/HELP';
  205. var
  206.   i,p : integer;
  207. begin
  208.   p := paramcount;
  209.   while p > 0 do
  210.    begin
  211.      i := pos(UpStr(ParamStr(p)),Prms);
  212.      case i of
  213.        1  : Level0_Simulation(True);
  214.        6  : ANSI_Only;
  215.        11 : Slowdown := 2; { set to ms between chars. }
  216.        16..18 : Help;
  217.      else
  218.       fname := ParamStr(p);
  219.      end; { case }
  220.      dec(p);
  221.    end; { while }
  222. end;  { processed in reverse so that first non-parameter is the filename }
  223.  
  224. Procedure ProgBody;
  225. var
  226.   f : file;
  227.   buf : Array[1..1024] of char;
  228.   i,z : word;
  229. begin
  230.   Assign(Output,''); Rewrite(Output);
  231.   Assign(Input,''); Reset(Input);
  232.   fname := '';
  233.   ANSI_BBS := True;
  234.   SetScrPtr;
  235.   SetHooks;
  236.   ProcessParams;
  237.   if fname = '' then Help;
  238.   FillArea(1,1,80,25,0,' '); { Clear Screen }
  239.   Assign(f,fname);
  240.   Reset(f,1);
  241.   if slowdown = 0 then
  242.    repeat
  243.      BlockRead(f,buf,1024,z);
  244.      for i := 1 to z do Parse_AVT1(buf[i]);
  245.    until EOF(f)
  246.   else
  247.    repeat
  248.      BlockRead(f,buf,1024,z);
  249.      for i := 1 to z do
  250.       begin
  251.         Delay(slowdown);
  252.         Parse_AVT1(buf[i]);
  253.       end;
  254.    until EOF(f); { end else }
  255. end;
  256.  
  257. begin
  258.   ProgBody;
  259. end.
  260.